BBS Toolkit/BBS Toolkit.iso/doors_1/fd200.zip/FD_AVL.PAS

Pascal/Delphi Source File | 1988-02-27 | 5KB | 209 lines

function modestr(s : mode): any_string;
begin
  case s of
    CW     : modestr := 'CW';
    AM     : modestr := 'AM';
    FM     : modestr := 'FM';
    SSB    : modestr := 'SB';
    RTTY   : modestr := 'RY';
    AMTOR  : modestr := 'MT';
    PACKET : modestr := 'PK';
  end;
end;

function pmodstr(s : mode): any_string;
begin
  case s of
    CW     : pmodstr := '    CW';
    AM     : pmodstr := '    AM';
    FM     : pmodstr := '    FM';
    SSB    : pmodstr := '   SSB';
    RTTY   : pmodstr := '  RTTY';
    AMTOR  : pmodstr := ' AMTOR';
    PACKET : pmodstr := 'PACKET';
  end;
end;

function bandstr(b : hamband): any_string;
begin
  case b of
    B160   : bandstr := '160';
    B80    : bandstr := ' 80';
    B40    : bandstr := ' 40';
    B20    : bandstr := ' 20';
    B15    : bandstr := ' 15';
    B10    : bandstr := ' 10';
    B6     : bandstr := '  6';
    B2     : bandstr := '  2';
    B220   : bandstr := '220';
    B440   : bandstr := '440';
  end;
end;

function check_mode(mode1, mode2 : mode): integer;
begin
  case mode1 of
    CW, RTTY, AMTOR : case mode2 of
                               CW, RTTY, AMTOR : check_mode := 0;
                               AM, FM, SSB, PACKET : check_mode := 1;
                             end;
    AM, FM, SSB            : case mode2 of
                               CW, RTTY, AMTOR : check_mode := -1;
                               AM, FM, SSB            : check_mode := 0;
                               PACKET                 : check_mode := 1;
                             end;
    PACKET : case mode2 of
               PACKET : check_mode := 0;
               else     check_mode := -1;
             end;
  end;
end;

function cmp;
begin
  if (d1.callsign < d2.callsign)
  then cmp := -1
  else if (d1.callsign > d2.callsign)
       then cmp := 1
       else if (d1.band < d2.band)
            then cmp := -1
            else if (d1.band > d2.band)
                 then cmp := 1
                 else cmp := check_mode(d1.xmtmode,d2.xmtmode);
end;

procedure print;
var pkey : char;
begin
  with pdata do
  begin
    line_nbr := line_nbr + 1;
    gotoxy(14,line_nbr);
    writeln(callsign:6,
            class:5,
            pmodstr(xmtmode):7,
            bandstr(band):4,
            section: 15,
            date:9,time:6);
  end;
  if line_nbr = 23 then
  begin
    gotoxy(14,24);
    write('<ESC>ape to quit print, <Retrn> for next page ..');
    repeat pkey := readkey until pkey in [#13,#27];
    if pkey = #27 then escape := TRUE;
    ClrScr;
    line_nbr := 0;
  end;
end;

procedure fprint;
begin
  with pdata do
    writeln(fd_file,callsign:6,
                    class:3,
                    modestr(xmtmode):2,
                    bandstr(band):3,
                    section: 14,
                    date:8,time:5);
end;

procedure read_file;
var  filename : file_type;
     source   : any_string;
     point,i,error : integer;
     fd_file : text;
     p : LINK;

  procedure read_line;
  var tstr : string[2];
      bstr : string[3];
  begin
    with p^.leaf do
    begin
      readln(fd_file,callsign, class, tstr, bstr, section, date, time);
      if tstr = 'PK' then xmtmode := PACKET
        else if tstr = 'MT' then xmtmode := AMTOR
          else if tstr = 'RY' then xmtmode := RTTY
            else if tstr = 'SB' then xmtmode := SSB
              else if tstr = 'FM' then xmtmode := FM
                else if tstr = 'AM' then xmtmode := AM
                  else xmtmode := CW;
      if bstr = '160' then band := B160
        else if bstr = ' 80' then band := B80
          else if bstr = ' 40' then band := B40
            else if bstr = ' 20' then band := B20
              else if bstr = ' 10' then band := B10
                else if bstr = '  6' then band := B6
                  else if bstr = '  2' then band := B2
                    else if bstr = '220' then band := B220
                      else band := B440;
    end;
    add_to_score(p^.leaf);
    insert(root,p);
  end;

begin
  get_file_name(filename,1,1,default_file,1,1,80,24);
  if (filename = '') then filename := default_file;
  default_file := filename;
  assign(fd_file,filename);
  {$I-}
  reset(fd_file);
  if (IOresult <> 0)
  then
    begin
      ClrScr;
      writeln('File not found');
      writeln;
      write('Press any key to continue..');
      wait_for_key;
      ClrScr;
    end
  else
    begin
      writeln;
      while (NOT Eof(fd_file)) do
      begin
        p := talloc;
        if (p <> NIL) then read_line;
      end;
    end;
  close(fd_file);
end;

procedure write_file(root: LINK);
var  filename : file_type;
     i : integer;
begin
  escape := FALSE;
  for i := 0 to 1023 do map[i] := 0;
  depth := -1;
  window(1,1,80,24);
  ClrScr;
  get_file_name(filename,1,1,default_file,1,1,80,24);
  if (filename = '') then filename := default_file;
  assign(fd_file,filename);
  {$I-}
  rewrite(fd_file);
  i := IOresult;
  if (i <> 0)
  then
    begin
      writeln; writeln('Unable to open file ',filename,' -  error = ',i);
      write('Press any key to continue ...');
      wait_for_key;
      {$I-}
      close(fd_file);
      i := IOresult;
    end
  else
  begin
    writeln; write('Writing records ...');
    trav( root, R, 1);
    close(fd_file);
  end;
  window(1,1,80,25);
end;